home *** CD-ROM | disk | FTP | other *** search
/ PC-Blue - MS DOS Public Domain Library / PC-Blue MS-DOS Public Domain Library - NYACC.iso / vol146 / xllist.c < prev    next >
Encoding:
C/C++ Source or Header  |  1986-12-16  |  18.5 KB  |  860 lines
  1. /* xllist - xlisp built-in list functions */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. #ifdef MEGAMAX
  9. overlay "overflow"
  10. #endif
  11.  
  12. /* external variables */
  13. extern NODE *xlstack;
  14. extern NODE *s_unbound;
  15. extern NODE *true;
  16.  
  17. /* external routines */
  18. extern int eq(),eql(),equal();
  19.  
  20. /* forward declarations */
  21. FORWARD NODE *cxr();
  22. FORWARD NODE *nth(),*assoc();
  23. FORWARD NODE *subst(),*sublis(),*map();
  24. FORWARD NODE *cequal();
  25.  
  26. /* xcar - return the car of a list */
  27. NODE *xcar(args)
  28.   NODE *args;
  29. {
  30.     return (cxr(args,"a"));
  31. }
  32.  
  33. /* xcdr - return the cdr of a list */
  34. NODE *xcdr(args)
  35.   NODE *args;
  36. {
  37.     return (cxr(args,"d"));
  38. }
  39.  
  40. /* xcaar - return the caar of a list */
  41. NODE *xcaar(args)
  42.   NODE *args;
  43. {
  44.     return (cxr(args,"aa"));
  45. }
  46.  
  47. /* xcadr - return the cadr of a list */
  48. NODE *xcadr(args)
  49.   NODE *args;
  50. {
  51.     return (cxr(args,"da"));
  52. }
  53.  
  54. /* xcdar - return the cdar of a list */
  55. NODE *xcdar(args)
  56.   NODE *args;
  57. {
  58.     return (cxr(args,"ad"));
  59. }
  60.  
  61. /* xcddr - return the cddr of a list */
  62. NODE *xcddr(args)
  63.   NODE *args;
  64. {
  65.     return (cxr(args,"dd"));
  66. }
  67.  
  68. /* cxr - common car/cdr routine */
  69. LOCAL NODE *cxr(args,adstr)
  70.   NODE *args; char *adstr;
  71. {
  72.     NODE *list;
  73.  
  74.     /* get the list */
  75.     list = xlmatch(LIST,&args);
  76.     xllastarg(args);
  77.  
  78.     /* perform the car/cdr operations */
  79.     while (*adstr && consp(list))
  80.     list = (*adstr++ == 'a' ? car(list) : cdr(list));
  81.  
  82.     /* make sure the operation succeeded */
  83.     if (*adstr && list)
  84.     xlfail("bad argument");
  85.  
  86.     /* return the result */
  87.     return (list);
  88. }
  89.  
  90. /* xcons - construct a new list cell */
  91. NODE *xcons(args)
  92.   NODE *args;
  93. {
  94.     NODE *arg1,*arg2,*val;
  95.  
  96.     /* get the two arguments */
  97.     arg1 = xlarg(&args);
  98.     arg2 = xlarg(&args);
  99.     xllastarg(args);
  100.  
  101.     /* construct a new list element */
  102.     val = newnode(LIST);
  103.     rplaca(val,arg1);
  104.     rplacd(val,arg2);
  105.  
  106.     /* return the list */
  107.     return (val);
  108. }
  109.  
  110. /* xlist - built a list of the arguments */
  111. NODE *xlist(args)
  112.   NODE *args;
  113. {
  114.     NODE *oldstk,arg,list,val,*last,*lptr;
  115.  
  116.     /* create a new stack frame */
  117.     oldstk = xlsave(&arg,&list,&val,NULL);
  118.  
  119.     /* initialize */
  120.     arg.n_ptr = args;
  121.  
  122.     /* evaluate and append each argument */
  123.     for (last = NIL; arg.n_ptr != NIL; last = lptr) {
  124.  
  125.     /* evaluate the next argument */
  126.     val.n_ptr = xlarg(&arg.n_ptr);
  127.  
  128.     /* append this argument to the end of the list */
  129.     lptr = newnode(LIST);
  130.     if (last == NIL)
  131.         list.n_ptr = lptr;
  132.     else
  133.         rplacd(last,lptr);
  134.     rplaca(lptr,val.n_ptr);
  135.     }
  136.  
  137.     /* restore the previous stack frame */
  138.     xlstack = oldstk;
  139.  
  140.     /* return the list */
  141.     return (list.n_ptr);
  142. }
  143.  
  144. /* xappend - built-in function append */
  145. NODE *xappend(args)
  146.   NODE *args;
  147. {
  148.     NODE *oldstk,arg,list,last,val,*lptr;
  149.  
  150.     /* create a new stack frame */
  151.     oldstk = xlsave(&arg,&list,&last,&val,NULL);
  152.  
  153.     /* initialize */
  154.     arg.n_ptr = args;
  155.  
  156.     /* evaluate and append each argument */
  157.     while (arg.n_ptr) {
  158.  
  159.     /* evaluate the next argument */
  160.     list.n_ptr = xlmatch(LIST,&arg.n_ptr);
  161.  
  162.     /* append each element of this list to the result list */
  163.     while (consp(list.n_ptr)) {
  164.  
  165.         /* append this element */
  166.         lptr = newnode(LIST);
  167.         if (last.n_ptr == NIL)
  168.         val.n_ptr = lptr;
  169.         else
  170.         rplacd(last.n_ptr,lptr);
  171.         rplaca(lptr,car(list.n_ptr));
  172.  
  173.         /* save the new last element */
  174.         last.n_ptr = lptr;
  175.  
  176.         /* move to the next element */
  177.         list.n_ptr = cdr(list.n_ptr);
  178.     }
  179.     }
  180.  
  181.     /* restore previous stack frame */
  182.     xlstack = oldstk;
  183.  
  184.     /* return the list */
  185.     return (val.n_ptr);
  186. }
  187.  
  188. /* xreverse - built-in function reverse */
  189. NODE *xreverse(args)
  190.   NODE *args;
  191. {
  192.     NODE *oldstk,list,val,*lptr;
  193.  
  194.     /* create a new stack frame */
  195.     oldstk = xlsave(&list,&val,NULL);
  196.  
  197.     /* get the list to reverse */
  198.     list.n_ptr = xlmatch(LIST,&args);
  199.     xllastarg(args);
  200.  
  201.     /* append each element of this list to the result list */
  202.     while (consp(list.n_ptr)) {
  203.  
  204.     /* append this element */
  205.     lptr = newnode(LIST);
  206.     rplaca(lptr,car(list.n_ptr));
  207.     rplacd(lptr,val.n_ptr);
  208.     val.n_ptr = lptr;
  209.  
  210.     /* move to the next element */
  211.     list.n_ptr = cdr(list.n_ptr);
  212.     }
  213.  
  214.     /* restore previous stack frame */
  215.     xlstack = oldstk;
  216.  
  217.     /* return the list */
  218.     return (val.n_ptr);
  219. }
  220.  
  221. /* xlast - return the last cons of a list */
  222. NODE *xlast(args)
  223.   NODE *args;
  224. {
  225.     NODE *list;
  226.  
  227.     /* get the list */
  228.     list = xlmatch(LIST,&args);
  229.     xllastarg(args);
  230.  
  231.     /* find the last cons */
  232.     while (consp(list) && cdr(list))
  233.     list = cdr(list);
  234.  
  235.     /* return the last element */
  236.     return (list);
  237. }
  238.  
  239. /* xmember - built-in function 'member' */
  240. NODE *xmember(args)
  241.   NODE *args;
  242. {
  243.     NODE *oldstk,x,list,fcn,*val;
  244.     int tresult;
  245.  
  246.     /* create a new stack frame */
  247.     oldstk = xlsave(&x,&list,&fcn,NULL);
  248.  
  249.     /* get the expression to look for and the list */
  250.     x.n_ptr = xlarg(&args);
  251.     list.n_ptr = xlmatch(LIST,&args);
  252.     xltest(&fcn.n_ptr,&tresult,&args);
  253.     xllastarg(args);
  254.  
  255.     /* look for the expression */
  256.     for (val = NIL; consp(list.n_ptr); list.n_ptr = cdr(list.n_ptr))
  257.     if (dotest(x.n_ptr,car(list.n_ptr),fcn.n_ptr) == tresult) {
  258.         val = list.n_ptr;
  259.         break;
  260.     }
  261.  
  262.     /* restore the previous stack frame */
  263.     xlstack = oldstk;
  264.  
  265.     /* return the result */
  266.     return (val);
  267. }
  268.  
  269. /* xassoc - built-in function 'assoc' */
  270. NODE *xassoc(args)
  271.   NODE *args;
  272. {
  273.     NODE *oldstk,x,alist,fcn,*pair,*val;
  274.     int tresult;
  275.  
  276.     /* create a new stack frame */
  277.     oldstk = xlsave(&x,&alist,&fcn,NULL);
  278.  
  279.     /* get the expression to look for and the association list */
  280.     x.n_ptr = xlarg(&args);
  281.     alist.n_ptr = xlmatch(LIST,&args);
  282.     xltest(&fcn.n_ptr,&tresult,&args);
  283.     xllastarg(args);
  284.  
  285.     /* look for the expression */
  286.     for (val = NIL; consp(alist.n_ptr); alist.n_ptr = cdr(alist.n_ptr))
  287.     if ((pair = car(alist.n_ptr)) && consp(pair))
  288.         if (dotest(x.n_ptr,car(pair),fcn.n_ptr) == tresult) {
  289.         val = pair;
  290.         break;
  291.         }
  292.  
  293.     /* restore the previous stack frame */
  294.     xlstack = oldstk;
  295.  
  296.     /* return the result */
  297.     return (val);
  298. }
  299.  
  300. /* xsubst - substitute one expression for another */
  301. NODE *xsubst(args)
  302.   NODE *args;
  303. {
  304.     NODE *oldstk,to,from,expr,fcn,*val;
  305.     int tresult;
  306.  
  307.     /* create a new stack frame */
  308.     oldstk = xlsave(&to,&from,&expr,&fcn,NULL);
  309.  
  310.     /* get the to value, the from value and the expression */
  311.     to.n_ptr = xlarg(&args);
  312.     from.n_ptr = xlarg(&args);
  313.     expr.n_ptr = xlarg(&args);
  314.     xltest(&fcn.n_ptr,&tresult,&args);
  315.     xllastarg(args);
  316.  
  317.     /* do the substitution */
  318.     val = subst(to.n_ptr,from.n_ptr,expr.n_ptr,fcn.n_ptr,tresult);
  319.  
  320.     /* restore the previous stack frame */
  321.     xlstack = oldstk;
  322.  
  323.     /* return the result */
  324.     return (val);
  325. }
  326.  
  327. /* subst - substitute one expression for another */
  328. LOCAL NODE *subst(to,from,expr,fcn,tresult)
  329.   NODE *to,*from,*expr,*fcn; int tresult;
  330. {
  331.     NODE *oldstk,carval,cdrval,*val;
  332.  
  333.     if (dotest(expr,from,fcn) == tresult)
  334.     val = to;
  335.     else if (consp(expr)) {
  336.     oldstk = xlsave(&carval,&cdrval,NULL);
  337.     carval.n_ptr = subst(to,from,car(expr),fcn,tresult);
  338.     cdrval.n_ptr = subst(to,from,cdr(expr),fcn,tresult);
  339.     val = newnode(LIST);
  340.     rplaca(val,carval.n_ptr);
  341.     rplacd(val,cdrval.n_ptr);
  342.     xlstack = oldstk;
  343.     }
  344.     else
  345.     val = expr;
  346.     return (val);
  347. }
  348.  
  349. /* xsublis - substitute using an association list */
  350. NODE *xsublis(args)
  351.   NODE *args;
  352. {
  353.     NODE *oldstk,alist,expr,fcn,*val;
  354.     int tresult;
  355.  
  356.     /* create a new stack frame */
  357.     oldstk = xlsave(&alist,&expr,&fcn,NULL);
  358.  
  359.     /* get the assocation list and the expression */
  360.     alist.n_ptr = xlmatch(LIST,&args);
  361.     expr.n_ptr = xlarg(&args);
  362.     xltest(&fcn.n_ptr,&tresult,&args);
  363.     xllastarg(args);
  364.  
  365.     /* do the substitution */
  366.     val = sublis(alist.n_ptr,expr.n_ptr,fcn.n_ptr,tresult);
  367.  
  368.     /* restore the previous stack frame */
  369.     xlstack = oldstk;
  370.  
  371.     /* return the result */
  372.     return (val);
  373. }
  374.  
  375. /* sublis - substitute using an association list */
  376. LOCAL NODE *sublis(alist,expr,fcn,tresult)
  377.   NODE *alist,*expr,*fcn; int tresult;
  378. {
  379.     NODE *oldstk,carval,cdrval,*val;
  380.  
  381.     if (val = assoc(expr,alist,fcn,tresult))
  382.     val = cdr(val);
  383.     else if (consp(expr)) {
  384.     oldstk = xlsave(&carval,&cdrval,NULL);
  385.     carval.n_ptr = sublis(alist,car(expr),fcn,tresult);
  386.     cdrval.n_ptr = sublis(alist,cdr(expr),fcn,tresult);
  387.     val = newnode(LIST);
  388.     rplaca(val,carval.n_ptr);
  389.     rplacd(val,cdrval.n_ptr);
  390.     xlstack = oldstk;
  391.     }
  392.     else
  393.     val = expr;
  394.     return (val);
  395. }
  396.  
  397. /* assoc - find a pair in an association list */
  398. LOCAL NODE *assoc(expr,alist,fcn,tresult)
  399.   NODE *expr,*alist,*fcn; int tresult;
  400. {
  401.     NODE *pair;
  402.  
  403.     for (; consp(alist); alist = cdr(alist))
  404.     if ((pair = car(alist)) && consp(pair))
  405.         if (dotest(expr,car(pair),fcn) == tresult)
  406.         return (pair);
  407.     return (NIL);
  408. }
  409.  
  410. /* xremove - built-in function 'remove' */
  411. NODE *xremove(args)
  412.   NODE *args;
  413. {
  414.     NODE *oldstk,x,list,fcn,val,*p,*last;
  415.     int tresult;
  416.  
  417.     /* create a new stack frame */
  418.     oldstk = xlsave(&x,&list,&fcn,&val,NULL);
  419.  
  420.     /* get the expression to remove and the list */
  421.     x.n_ptr = xlarg(&args);
  422.     list.n_ptr = xlmatch(LIST,&args);
  423.     xltest(&fcn.n_ptr,&tresult,&args);
  424.     xllastarg(args);
  425.  
  426.     /* remove matches */
  427.     while (consp(list.n_ptr)) {
  428.  
  429.     /* check to see if this element should be deleted */
  430.     if (dotest(x.n_ptr,car(list.n_ptr),fcn.n_ptr) != tresult) {
  431.         p = newnode(LIST);
  432.         rplaca(p,car(list.n_ptr));
  433.         if (val.n_ptr) rplacd(last,p);
  434.         else val.n_ptr = p;
  435.         last = p;
  436.     }
  437.  
  438.     /* move to the next element */
  439.     list.n_ptr = cdr(list.n_ptr);
  440.     }
  441.  
  442.     /* restore the previous stack frame */
  443.     xlstack = oldstk;
  444.  
  445.     /* return the updated list */
  446.     return (val.n_ptr);
  447. }
  448.  
  449. /* dotest - call a test function */
  450. int dotest(arg1,arg2,fcn)
  451.   NODE *arg1,*arg2,*fcn;
  452. {
  453.     NODE *oldstk,args,*val;
  454.  
  455.     /* create a new stack frame */
  456.     oldstk = xlsave(&args,NULL);
  457.  
  458.     /* build an argument list */
  459.     args.n_ptr = newnode(LIST);
  460.     rplaca(args.n_ptr,arg1);
  461.     rplacd(args.n_ptr,newnode(LIST));
  462.     rplaca(cdr(args.n_ptr),arg2);
  463.  
  464.     /* apply the test function */
  465.     val = xlapply(fcn,args.n_ptr);
  466.  
  467.     /* restore the previous stack frame */
  468.     xlstack = oldstk;
  469.  
  470.     /* return the result of the test */
  471.     return (val != NIL);
  472. }
  473.  
  474. /* xnth - return the nth element of a list */
  475. NODE *xnth(args)
  476.   NODE *args;
  477. {
  478.     return (nth(args,TRUE));
  479. }
  480.  
  481. /* xnthcdr - return the nth cdr of a list */
  482. NODE *xnthcdr(args)
  483.   NODE *args;
  484. {
  485.     return (nth(args,FALSE));
  486. }
  487.  
  488. /* nth - internal nth function */
  489. LOCAL NODE *nth(args,carflag)
  490.   NODE *args; int carflag;
  491. {
  492.     NODE *list;
  493.     int n;
  494.  
  495.     /* get n and the list */
  496.     if ((n = xlmatch(INT,&args)->n_int) < 0)
  497.     xlfail("bad argument");
  498.     if ((list = xlmatch(LIST,&args)) == NIL)
  499.     xlfail("bad argument");
  500.     xllastarg(args);
  501.  
  502.     /* find the nth element */
  503.     while (consp(list) && n--)
  504.     list = cdr(list);
  505.  
  506.     /* return the list beginning at the nth element */
  507.     return (carflag && consp(list) ? car(list) : list);
  508. }
  509.  
  510. /* xlength - return the length of a list or string */
  511. NODE *xlength(args)
  512.   NODE *args;
  513. {
  514.     NODE *arg;
  515.     int n;
  516.  
  517.     /* get the list or string */
  518.     arg = xlarg(&args);
  519.     xllastarg(args);
  520.  
  521.     /* find the length of a list */
  522.     if (listp(arg))
  523.     for (n = 0; consp(arg); n++)
  524.         arg = cdr(arg);
  525.  
  526.     /* find the length of a string */
  527.     else if (stringp(arg))
  528.     n = strlen(arg->n_str);
  529.  
  530.     /* otherwise, bad argument type */
  531.     else
  532.     xlerror("bad argument type",arg);
  533.  
  534.     /* return the length */
  535.     return (cvfixnum((FIXNUM)n));
  536. }
  537.  
  538. /* xmapc - built-in function 'mapc' */
  539. NODE *xmapc(args)
  540.   NODE *args;
  541. {
  542.     return (map(args,TRUE,FALSE));
  543. }
  544.  
  545. /* xmapcar - built-in function 'mapcar' */
  546. NODE *xmapcar(args)
  547.   NODE *args;
  548. {
  549.     return (map(args,TRUE,TRUE));
  550. }
  551.  
  552. /* xmapl - built-in function 'mapl' */
  553. NODE *xmapl(args)
  554.   NODE *args;
  555. {
  556.     return (map(args,FALSE,FALSE));
  557. }
  558.  
  559. /* xmaplist - built-in function 'maplist' */
  560. NODE *xmaplist(args)
  561.   NODE *args;
  562. {
  563.     return (map(args,FALSE,TRUE));
  564. }
  565.  
  566. /* map - internal mapping function */
  567. LOCAL NODE *map(args,carflag,valflag)
  568.   NODE *args; int carflag,valflag;
  569. {
  570.     NODE *oldstk,fcn,lists,arglist,val,*last,*p,*x,*y;
  571.  
  572.     /* create a new stack frame */
  573.     oldstk = xlsave(&fcn,&lists,&arglist,&val,NULL);
  574.  
  575.     /* get the function to apply and the first list */
  576.     fcn.n_ptr = xlarg(&args);
  577.     lists.n_ptr = xlmatch(LIST,&args);
  578.  
  579.     /* save the first list if not saving function values */
  580.     if (!valflag)
  581.     val.n_ptr = lists.n_ptr;
  582.  
  583.     /* set up the list of argument lists */
  584.     p = newnode(LIST);
  585.     rplaca(p,lists.n_ptr);
  586.     lists.n_ptr = p;
  587.  
  588.     /* get the remaining argument lists */
  589.     while (args) {
  590.     p = newnode(LIST);
  591.     rplacd(p,lists.n_ptr);
  592.     lists.n_ptr = p;
  593.     rplaca(p,xlmatch(LIST,&args));
  594.     }
  595.  
  596.     /* if the function is a symbol, get its value */
  597.     if (symbolp(fcn.n_ptr))
  598.     fcn.n_ptr = xleval(fcn.n_ptr);
  599.  
  600.     /* loop through each of the argument lists */
  601.     for (;;) {
  602.  
  603.     /* build an argument list from the sublists */
  604.     arglist.n_ptr = NIL;
  605.     for (x = lists.n_ptr; x && (y = car(x)) && consp(y); x = cdr(x)) {
  606.         p = newnode(LIST);
  607.         rplacd(p,arglist.n_ptr);
  608.         arglist.n_ptr = p;
  609.         rplaca(p,carflag ? car(y) : y);
  610.         rplaca(x,cdr(y));
  611.     }
  612.  
  613.     /* quit if any of the lists were empty */
  614.     if (x) break;
  615.  
  616.     /* apply the function to the arguments */
  617.     if (valflag) {
  618.         p = newnode(LIST);
  619.         if (val.n_ptr) rplacd(last,p);
  620.         else val.n_ptr = p;
  621.         rplaca(p,xlapply(fcn.n_ptr,arglist.n_ptr));
  622.         last = p;
  623.     }
  624.     else
  625.         xlapply(fcn.n_ptr,arglist.n_ptr);
  626.     }
  627.  
  628.     /* restore the previous stack frame */
  629.     xlstack = oldstk;
  630.  
  631.     /* return the last test expression value */
  632.     return (val.n_ptr);
  633. }
  634.  
  635. /* xrplca - replace the car of a list node */
  636. NODE *xrplca(args)
  637.   NODE *args;
  638. {
  639.     NODE *list,*newcar;
  640.  
  641.     /* get the list and the new car */
  642.     if ((list = xlmatch(LIST,&args)) == NIL)
  643.     xlfail("bad argument");
  644.     newcar = xlarg(&args);
  645.     xllastarg(args);
  646.  
  647.     /* replace the car */
  648.     rplaca(list,newcar);
  649.  
  650.     /* return the list node that was modified */
  651.     return (list);
  652. }
  653.  
  654. /* xrplcd - replace the cdr of a list node */
  655. NODE *xrplcd(args)
  656.   NODE *args;
  657. {
  658.     NODE *list,*newcdr;
  659.  
  660.     /* get the list and the new cdr */
  661.     if ((list = xlmatch(LIST,&args)) == NIL)
  662.     xlfail("bad argument");
  663.     newcdr = xlarg(&args);
  664.     xllastarg(args);
  665.  
  666.     /* replace the cdr */
  667.     rplacd(list,newcdr);
  668.  
  669.     /* return the list node that was modified */
  670.     return (list);
  671. }
  672.  
  673. /* xnconc - destructively append lists */
  674. NODE *xnconc(args)
  675.   NODE *args;
  676. {
  677.     NODE *list,*last,*val;
  678.  
  679.     /* concatenate each argument */
  680.     for (val = NIL; args; ) {
  681.  
  682.     /* concatenate this list */
  683.     if (list = xlmatch(LIST,&args)) {
  684.  
  685.         /* check for this being the first non-empty list */
  686.         if (val)
  687.         rplacd(last,list);
  688.         else
  689.         val = list;
  690.  
  691.         /* find the end of the list */
  692.         while (consp(cdr(list)))
  693.         list = cdr(list);
  694.  
  695.         /* save the new last element */
  696.         last = list;
  697.     }
  698.     }
  699.  
  700.     /* return the list */
  701.     return (val);
  702. }
  703.  
  704. /* xdelete - built-in function 'delete' */
  705. NODE *xdelete(args)
  706.   NODE *args;
  707. {
  708.     NODE *oldstk,x,list,fcn,*last,*val;
  709.     int tresult;
  710.  
  711.     /* create a new stack frame */
  712.     oldstk = xlsave(&x,&list,&fcn,NULL);
  713.  
  714.     /* get the expression to delete and the list */
  715.     x.n_ptr = xlarg(&args);
  716.     list.n_ptr = xlmatch(LIST,&args);
  717.     xltest(&fcn.n_ptr,&tresult,&args);
  718.     xllastarg(args);
  719.  
  720.     /* delete leading matches */
  721.     while (consp(list.n_ptr)) {
  722.     if (dotest(x.n_ptr,car(list.n_ptr),fcn.n_ptr) != tresult)
  723.         break;
  724.     list.n_ptr = cdr(list.n_ptr);
  725.     }
  726.     val = last = list.n_ptr;
  727.  
  728.     /* delete embedded matches */
  729.     if (consp(list.n_ptr)) {
  730.  
  731.     /* skip the first non-matching element */
  732.     list.n_ptr = cdr(list.n_ptr);
  733.  
  734.     /* look for embedded matches */
  735.     while (consp(list.n_ptr)) {
  736.  
  737.         /* check to see if this element should be deleted */
  738.         if (dotest(x.n_ptr,car(list.n_ptr),fcn.n_ptr) == tresult)
  739.         rplacd(last,cdr(list.n_ptr));
  740.         else
  741.         last = list.n_ptr;
  742.  
  743.         /* move to the next element */
  744.         list.n_ptr = cdr(list.n_ptr);
  745.      }
  746.     }
  747.  
  748.     /* restore the previous stack frame */
  749.     xlstack = oldstk;
  750.  
  751.     /* return the updated list */
  752.     return (val);
  753. }
  754.  
  755. /* xatom - is this an atom? */
  756. NODE *xatom(args)
  757.   NODE *args;
  758. {
  759.     NODE *arg;
  760.     arg = xlarg(&args);
  761.     xllastarg(args);
  762.     return (atom(arg) ? true : NIL);
  763. }
  764.  
  765. /* xsymbolp - is this an symbol? */
  766. NODE *xsymbolp(args)
  767.   NODE *args;
  768. {
  769.     NODE *arg;
  770.     arg = xlarg(&args);
  771.     xllastarg(args);
  772.     return (arg == NIL || symbolp(arg) ? true : NIL);
  773. }
  774.  
  775. /* xnumberp - is this a number? */
  776. NODE *xnumberp(args)
  777.   NODE *args;
  778. {
  779.     NODE *arg;
  780.     arg = xlarg(&args);
  781.     xllastarg(args);
  782.     return (fixp(arg) || floatp(arg) ? true : NIL);
  783. }
  784.  
  785. /* xboundp - is this a value bound to this symbol? */
  786. NODE *xboundp(args)
  787.   NODE *args;
  788. {
  789.     NODE *sym;
  790.     sym = xlmatch(SYM,&args);
  791.     xllastarg(args);
  792.     return (xlxgetvalue(sym) == s_unbound ? NIL : true);
  793. }
  794.  
  795. /* xnull - is this null? */
  796. NODE *xnull(args)
  797.   NODE *args;
  798. {
  799.     NODE *arg;
  800.     arg = xlarg(&args);
  801.     xllastarg(args);
  802.     return (null(arg) ? true : NIL);
  803. }
  804.  
  805. /* xlistp - is this a list? */
  806. NODE *xlistp(args)
  807.   NODE *args;
  808. {
  809.     NODE *arg;
  810.     arg = xlarg(&args);
  811.     xllastarg(args);
  812.     return (listp(arg) ? true : NIL);
  813. }
  814.  
  815. /* xconsp - is this a cons? */
  816. NODE *xconsp(args)
  817.   NODE *args;
  818. {
  819.     NODE *arg;
  820.     arg = xlarg(&args);
  821.     xllastarg(args);
  822.     return (consp(arg) ? true : NIL);
  823. }
  824.  
  825. /* xeq - are these equal? */
  826. NODE *xeq(args)
  827.   NODE *args;
  828. {
  829.     return (cequal(args,eq));
  830. }
  831.  
  832. /* xeql - are these equal? */
  833. NODE *xeql(args)
  834.   NODE *args;
  835. {
  836.     return (cequal(args,eql));
  837. }
  838.  
  839. /* xequal - are these equal? */
  840. NODE *xequal(args)
  841.   NODE *args;
  842. {
  843.     return (cequal(args,equal));
  844. }
  845.  
  846. /* cequal - common eq/eql/equal function */
  847. LOCAL NODE *cequal(args,fcn)
  848.   NODE *args; int (*fcn)();
  849. {
  850.     NODE *arg1,*arg2;
  851.  
  852.     /* get the two arguments */
  853.     arg1 = xlarg(&args);
  854.     arg2 = xlarg(&args);
  855.     xllastarg(args);
  856.  
  857.     /* compare the arguments */
  858.     return ((*fcn)(arg1,arg2) ? true : NIL);
  859. }
  860.